VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsQuadExtreme"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" (ByVal hdc As Long, ByRef lppt As POINTAPI, ByRef lpdwPolyPoints As Long, ByVal cCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As Long
Private Declare Function Ellipse Lib "gdi32.dll" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Const NULL_BRUSH As Long = 5
Private Const WHITE_BRUSH As Long = 0
Private Const BLACK_BRUSH As Long = 4

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Implements IGameState

Private Type typeQuadState
 nScore(1) As Long 'number of squares for each player (first player has 0.5 handicap)
 nPlayerJustMoved As Byte 'this also means the total quads on the board
 b(120) As Byte '1,2=quad of player, &H10,&H20=potential winning position (bitfield) (only for displaying purpose)
End Type

Private m_t As typeQuadState
Private m_bMove As Byte 'quad position

Private m_bDirty As Boolean 'if we need to recalculate potential positions for displaying

Private m_nSquareCount As Long
Private m_bSquares() As Byte 'format: x0 y0 dx dy

Private Sub IGameState_ClearUserMoves()
m_bMove = 0
End Sub

Friend Sub CloneFrom(ByRef t As typeQuadState)
m_t = t
End Sub

Private Function IGameState_Clone() As IGameState
Dim obj As New clsQuadExtreme
obj.CloneFrom m_t
Set IGameState_Clone = obj
End Function

'warning: no sanity check!
Private Function IGameState_DoMove(ByVal lpData As Long, ByVal nSize As Long) As Boolean
Dim idx As Long
Dim i As Long, j As Long, k As Long
Dim i0 As Long, j0 As Long
Dim ii As Long, jj As Long, kk As Long
Dim i2 As Long, j2 As Long, k2 As Long
Dim bMove As Byte
'///
If lpData = 0 Or nSize < 1 Then Exit Function
CopyMemory bMove, ByVal lpData, 1
'///
IGameState_DoMove = True
'///
idx = m_t.nPlayerJustMoved And 1&
'///place blocks
j = bMove - 1&
idx = idx + 1
m_t.b(j) = idx
'///update moves
m_t.nPlayerJustMoved = m_t.nPlayerJustMoved + 1
'///check newly created squares
If m_t.nPlayerJustMoved >= 7 Then
 j0 = j \ 11 'y of 0th corder
 i0 = j - j0 * 11 'x of 0th corner
 k = 0 'index of 1st corner
 For j = -j0 To 10 - j0 'dy of 1st corner
  For i = -i0 To 10 - i0 'dx of 1st corner
   If m_t.b(k) = idx Then
    If i <> 0 Or j <> 0 Then
     ii = i0 + i - j 'x of 2nd corner
     jj = j0 + j + i 'y of 2nd corner
     i2 = i0 - j 'x of 3rd corner
     j2 = j0 + i 'y of 3rd corner
     If ii >= 0 And jj >= 0 And ii < 11 And jj < 11 Then
      If i2 >= 0 And j2 >= 0 And i2 < 11 And j2 < 11 Then
       kk = jj * 11 + ii 'index of 2nd corner
       k2 = j2 * 11 + i2 'index of 3rd corner
       If m_t.b(kk) = idx Then
        If m_t.b(k2) = idx Then
         'get a new square
         m_t.nScore(idx - 1) = m_t.nScore(idx - 1) + 1
        End If
       End If
      End If
     End If
    End If
   End If
   k = k + 1
  Next i
 Next j
End If
m_bDirty = True
End Function

Private Function IGameState_Draw(ByVal bm As cDIBSection, ByVal nWidth As Long, ByVal nHeight As Long) As Boolean
Dim w As Long
Dim hbr(3) As Long, hpn(5) As Long
Dim r As RECT
Dim i As Long, j As Long, k As Long
Dim i0 As Long, j0 As Long
Dim ii As Long, jj As Long, kk As Long
Dim i2 As Long, j2 As Long, k2 As Long
Dim p(23) As POINTAPI, m2(11) As Long
'///check if we need to recalculate
If m_bDirty Then
 r.Right = 0 'index of 0th corner
 r.Bottom = 0 'max size of array of squares
 m_nSquareCount = 0
 For j0 = 0 To 10 'y of 0th corder
  For i0 = 0 To 10 'x of 0th corner
   hbr(0) = m_t.b(r.Right) And &HF& 'value of 0th corner
   For j = 0 To 10 - j0 'dy of 1st corner
    For i = 1 To 10 - i0 'dx of 1st corner
     k = r.Right + j * 11 + i 'index of 1st corner
     hbr(1) = m_t.b(k) And &HF& 'value of 1st corner
     'determine the common color
     If hbr(0) = 0 Then
      w = hbr(1)
     ElseIf hbr(1) = 0 Or hbr(1) = hbr(0) Then
      w = hbr(0)
     Else
      w = 0
     End If
     'if we have common color
     If w Then
      ii = i0 + i - j 'x of 2nd corner
      jj = j0 + j + i 'y of 2nd corner
      i2 = i0 - j 'x of 3rd corner
      j2 = j0 + i 'y of 3rd corner
      If ii >= 0 And jj >= 0 And ii < 11 And jj < 11 Then
       If i2 >= 0 And j2 >= 0 And i2 < 11 And j2 < 11 Then
        kk = jj * 11 + ii 'index of 2nd corner
        k2 = j2 * 11 + i2 'index of 3rd corner
        If m_t.b(kk) = w Then
         If m_t.b(k2) = w Then
          If hbr(0) = 0 Then '0th is empty
           m_t.b(r.Right) = m_t.b(r.Right) Or (w * &H10&)
          ElseIf hbr(1) = 0 Then '1st is empty
           m_t.b(k) = m_t.b(k) Or (w * &H10&)
          Else 'get a new square
           If m_nSquareCount >= r.Bottom Then
            r.Bottom = r.Bottom + 64&
            ReDim Preserve m_bSquares(r.Bottom * 4& - 1)
           End If
           m_bSquares(m_nSquareCount * 4&) = i0
           m_bSquares(m_nSquareCount * 4& + 1) = j0
           m_bSquares(m_nSquareCount * 4& + 2) = i
           m_bSquares(m_nSquareCount * 4& + 3) = j
           m_nSquareCount = m_nSquareCount + 1
          End If
         ElseIf (m_t.b(k2) And &HF&) = 0 And hbr(0) <> 0 And hbr(1) <> 0 Then '3rd is empty
          m_t.b(k2) = m_t.b(k2) Or (w * &H10&)
         End If
        ElseIf (m_t.b(kk) And &HF&) = 0 And m_t.b(k2) = w And hbr(0) <> 0 And hbr(1) <> 0 Then '2th is empty
         m_t.b(kk) = m_t.b(kk) Or (w * &H10&)
        End If
       End If
      End If
     End If
    Next i
   Next j
   r.Right = r.Right + 1
  Next i0
 Next j0
 'over
 m_bDirty = False
End If
'///
w = nWidth \ 11
i = nHeight \ 14
If w > i Then w = i
'///background
hbr(0) = CreateSolidBrush(GetSysColor(vbButtonFace And &HFF&))
r.Right = nWidth
r.Bottom = nHeight
FillRect bm.hdc, r, hbr(0)
DeleteObject hbr(0)
'///
hbr(0) = SelectObject(bm.hdc, GetStockObject(NULL_BRUSH))
hbr(1) = GetStockObject(BLACK_BRUSH)
hbr(2) = GetStockObject(WHITE_BRUSH)
hbr(3) = CreateSolidBrush(&H808080)
hpn(1) = CreatePen(0, 2, vbBlack)
hpn(2) = CreatePen(2, 1, vbBlack)
hpn(3) = CreatePen(0, 2, vbWhite)
hpn(4) = CreatePen(0, 1, vbBlack)
hpn(5) = CreatePen(0, 1, vbWhite)
hpn(0) = SelectObject(bm.hdc, hpn(1))
'///
For i = 0 To 11
 m2(i) = 2
Next i
'///draw GUI
Form1.m_fnt.DrawTextXP bm.hdc, "Reset", 0, 0, w * 2, w, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE Or DT_NOCLIP, vbBlack, , True
If m_bMove > 0 Then
 Form1.m_fnt.DrawTextXP bm.hdc, "OK", w * 9, 0, w * 2, w, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE Or DT_NOCLIP, vbBlack, , True
End If
r.Left = ((m_t.nPlayerJustMoved And 1&) <> 0 And (w * 9))
r.Top = w * 12
r.Right = r.Left + w * 2
r.Bottom = r.Top + w
FillRect bm.hdc, r, hbr(3)
SelectObject bm.hdc, hbr(1)
Ellipse bm.hdc, 4, r.Top + 4, w - 4, r.Bottom - 4
SelectObject bm.hdc, hbr(2)
Ellipse bm.hdc, w * 9 + 4, r.Top + 4, w * 10 - 4, r.Bottom - 4
Form1.m_fnt.DrawTextXP bm.hdc, ChrW(&H221E&), w, r.Top, w, w, DT_VCENTER Or DT_SINGLELINE Or DT_NOCLIP, vbBlack, , True
Form1.m_fnt.DrawTextXP bm.hdc, ChrW(&H221E&), w * 10, r.Top, w, w, DT_VCENTER Or DT_SINGLELINE Or DT_NOCLIP, vbBlack, , True
Form1.m_fnt.DrawTextXP bm.hdc, "Score: " + CStr(m_t.nScore(0)), 0, r.Top + w, 0, w, DT_VCENTER Or DT_SINGLELINE Or DT_NOCLIP, vbBlack, , True
Form1.m_fnt.DrawTextXP bm.hdc, "Score: " + Format(0.5! + m_t.nScore(1), "0.0"), w * 11, r.Top + w, 0, w, DT_RIGHT Or DT_VCENTER Or DT_SINGLELINE Or DT_NOCLIP, vbBlack, , True
'///draw chessboard
For i = 0 To 11
 p(i * 2).x = w * i
 p(i * 2).y = w
 p(i * 2 + 1).x = p(i * 2).x
 p(i * 2 + 1).y = w * 12
Next i
p(0).y = w * 2
p(1).y = p(1).y - w
p(22).y = w * 2
p(23).y = p(23).y - w
PolyPolyline bm.hdc, p(0), m2(0), 12&
For i = 0 To 23
 j = p(i).x + w
 p(i).x = p(i).y - w
 p(i).y = j
Next i
PolyPolyline bm.hdc, p(0), m2(0), 12&
'///draw marbles
k = 0
For j = 0 To 10
 p(0).x = 4
 p(0).y = w * (j + 1) + 4
 p(1).x = w - 4
 p(1).y = p(0).y + w - 8
 p(2).x = p(0).x
 p(2).y = p(1).y
 p(3).x = p(1).x
 p(3).y = p(0).y
 For i = 0 To 10
  Select Case m_t.b(k)
  Case 1
   SelectObject bm.hdc, hbr(1)
   Ellipse bm.hdc, p(0).x, p(0).y, p(1).x, p(1).y
  Case 2
   SelectObject bm.hdc, hbr(2)
   Ellipse bm.hdc, p(0).x, p(0).y, p(1).x, p(1).y
  End Select
  '///
  k = k + 1
  p(0).x = p(0).x + w
  p(1).x = p(1).x + w
  p(2).x = p(2).x + w
  p(3).x = p(3).x + w
 Next i
Next j
'///draw squares
m2(0) = 5
For kk = 0 To m_nSquareCount - 1
 i = m_bSquares(kk * 4&)
 j = m_bSquares(kk * 4& + 1)
 ii = m_bSquares(kk * 4& + 2)
 jj = m_bSquares(kk * 4& + 3)
 '///
 p(0).x = i
 p(0).y = j
 p(1).x = i + ii
 p(1).y = j + jj
 p(2).x = i + ii - jj
 p(2).y = j + ii + jj
 p(3).x = i - jj
 p(3).y = j + ii
 For k = 0 To 3
  p(k + 4).x = w * p(k).x + w \ 2
  p(k + 4).y = w * (p(k).y + 1) + w \ 2
 Next k
 p(8).x = p(4).x
 p(8).y = p(4).y
 '///
 i = m_t.b(j * 11 + i) And &H1&
 SelectObject bm.hdc, hpn(1 + i * 2&)
 PolyPolyline bm.hdc, p(4), m2(0), 1&
 SelectObject bm.hdc, hpn(5 - i)
 PolyPolyline bm.hdc, p(4), m2(0), 1&
Next kk
'///draw potential positions
k = 0
For j = 0 To 10
 p(0).x = 4
 p(0).y = w * (j + 1) + 4
 p(1).x = w - 4
 p(1).y = p(0).y + w - 8
 p(2).x = p(0).x
 p(2).y = p(1).y
 p(3).x = p(1).x
 p(3).y = p(0).y
 For i = 0 To 10
  If m_t.b(k) And &H30& Then
   If (i <> 0 And i <> 10) Or (j <> 0 And j <> 10) Then
    Form1.m_fnt.DrawTextXP bm.hdc, CStr(m_t.b(k) \ &H10&), w * i, w * (j + 1), w, w, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE Or DT_NOCLIP, vbBlack, , True
   End If
  End If
  '///
  k = k + 1
  p(0).x = p(0).x + w
  p(1).x = p(1).x + w
  p(2).x = p(2).x + w
  p(3).x = p(3).x + w
 Next i
Next j
'///draw candidates
j = m_bMove And &H7F&
If j > 0 Then
 j = j - 1
 k = j \ 11&
 j = j - k * 11&
 p(0).x = w * j + 4
 p(0).y = w * (k + 1) + 4
 p(1).x = p(0).x + w - 8
 p(1).y = p(0).y + w - 8
 SelectObject bm.hdc, hpn(2)
 SelectObject bm.hdc, hbr(3& - (m_t.nPlayerJustMoved And 1&))
 Ellipse bm.hdc, p(0).x, p(0).y, p(1).x, p(1).y
End If
'///over
SelectObject bm.hdc, hbr(0)
SelectObject bm.hdc, hpn(0)
DeleteObject hbr(3)
DeleteObject hpn(1)
DeleteObject hpn(2)
DeleteObject hpn(3)
DeleteObject hpn(4)
DeleteObject hpn(5)
End Function

Private Function IGameState_FilterByRandomFactor(ByVal lpData As Long, ByVal nSize As Long) As Boolean
IGameState_FilterByRandomFactor = True
End Function

Private Function IGameState_GetMoves(bData() As Byte, nSize As Long, ByVal bRespectRandomFactor As Boolean) As Long
Dim k As Long
Dim b2(119) As Byte, m2 As Long
'///
If m_t.nPlayerJustMoved >= 117& Then Exit Function
'///
nSize = 1
'///record empty position
For k = 1 To 119 'exclude corners
 If (m_t.b(k) And &HF&) = 0 And k <> 10 And k <> 110 Then
  b2(m2) = k + 1
  m2 = m2 + 1
 End If
Next k
'///list all moves
Debug.Assert m2 + m_t.nPlayerJustMoved = 117&
ReDim bData(m2 - 1)
IGameState_GetMoves = m2
For k = 0 To m2 - 1
 bData(k) = b2(k)
Next k
End Function

Private Function IGameState_GetRandomMoves(bData() As Byte, nSize As Long, ByVal bReversed As Boolean) As Boolean
Dim k As Long
Dim b2(119) As Byte, m2 As Long
'///
If m_t.nPlayerJustMoved >= 117& Then Exit Function
'///
nSize = 1
ReDim bData(0)
IGameState_GetRandomMoves = True
'///record empty position
For k = 1 To 119 'exclude corners
 If (m_t.b(k) And &HF&) = 0 And k <> 10 And k <> 110 Then
  b2(m2) = k + 1
  m2 = m2 + 1
 End If
Next k
'///create random move
Debug.Assert m2 + m_t.nPlayerJustMoved = 117&
bData(0) = b2(Int(m2 * Rnd))
End Function

Private Function IGameState_GetResult(ByVal nPlayerJustMoved As Long) As Long
Dim i As Long
If m_t.nPlayerJustMoved < 117 Then
 IGameState_GetResult = 3
Else
 IGameState_GetResult = (m_t.nScore(0) > m_t.nScore(1) Xor nPlayerJustMoved = 2) And 1&
End If
End Function

Private Function IGameState_GetUserMoves(bData() As Byte, nSize As Long) As Boolean
If m_bMove > 0 Then
 m_bMove = m_bMove And &H7F&
 nSize = 1
 ReDim bData(0)
 bData(0) = m_bMove
 IGameState_GetUserMoves = True
End If
End Function

Private Function IGameState_OnMouseDown(ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal Button As MouseButtonConstants, ByVal Shift As ShiftConstants) As Long
nWidth = nWidth \ 11
nHeight = nHeight \ 14
If nWidth > nHeight Then nWidth = nHeight
'///
If x < 0 Or y < 0 Then Exit Function
x = x \ nWidth
y = y \ nWidth
If x >= 11 Or y >= 12 Then Exit Function
'///
If Button = vbRightButton Then
 m_bMove = 0
 IGameState_OnMouseDown = 1
 Exit Function
ElseIf y = 0 Then
 If x <= 1 Then
  m_bMove = 0
  IGameState_OnMouseDown = 1
  Exit Function
 ElseIf x >= 9 And m_bMove > 0 Then
  IGameState_OnMouseDown = 2
  Exit Function
 End If
ElseIf (x <> 0 And x <> 10) Or (y <> 1 And y <> 11) Then
 y = (y - 1) * 11 + x
 If (m_t.b(y) And &HF&) = 0 Then
  'place block
  m_bMove = y + 1
  IGameState_OnMouseDown = 1
  Exit Function
 End If
End If
'///
Beep
End Function

Private Function IGameState_OnMouseMove(ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal Button As MouseButtonConstants, ByVal Shift As ShiftConstants) As Long
'do nothing
End Function

Private Function IGameState_OnMouseUp(ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal Button As MouseButtonConstants, ByVal Shift As ShiftConstants) As Long
'do nothing
End Function

Private Property Get IGameState_PlayerJustMoved() As Long
IGameState_PlayerJustMoved = 2& - (m_t.nPlayerJustMoved And 1&)
End Property
